home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / init.stk < prev    next >
Encoding:
Text File  |  1996-07-22  |  14.7 KB  |  503 lines
  1. ;;;;
  2. ;;;; i n i t . s t k            -- The file launched at startup
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  15. ;;;;    Creation date: ??-Sep-1993 ??:??
  16. ;;;; Last file update: 22-Jul-1996 15:47
  17. ;;;;
  18.  
  19.  
  20. (define *debug*        #f)    ; #t for debuggging (disable macro inlining)
  21. (define *gc-verbose*     #f)    ; #t to have a message at start/stop of a GC
  22. (define *print-banner*  #t)    ; #f to avoid the copyright message
  23.  
  24.  
  25. (define @undefined (if #f #t))
  26. (define *argc* (length *argv*)) 
  27.  
  28. (define call/cc        call-with-current-continuation)
  29. (define !        system)
  30.  
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32. ;;;;
  33. ;;;; Some stuff for defining macros
  34. ;;;;
  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36.  
  37. (define define-macro #f)
  38. (define %replace     #f)
  39. (define %beginify    #f)
  40.  
  41. (let ((if if) (and and) (begin begin) (set-car! set-car!) (set-cdr! set-cdr!)
  42.       (not not) (pair? pair?) (car car) (cdr cdr) 
  43.       (null? null?) (cons cons) 
  44.       (let let) (macro macro) (list list) (append append))
  45.  
  46.   (set! %replace
  47.     (lambda (before after)
  48.       (if (and (not *debug*) (pair? before) (pair? after))
  49.           (begin
  50.         (set-car! before (car after))
  51.         (set-cdr! before (cdr after))))
  52.       after))
  53.  
  54.   (set! %beginify 
  55.     (lambda (forms)
  56.       (if (null? (cdr forms)) (car forms) (cons 'begin forms))))
  57.  
  58.   (set! define-macro 
  59.     (macro form
  60.       (let ((name (car (car (cdr form))))
  61.         (args (cdr (car (cdr form)))))
  62.         (list 'define name
  63.           (list 'macro 'params
  64.             (list '%replace 
  65.                   'params
  66.                   (list 'apply
  67.                     (append (list 'lambda args)
  68.                         (cdr (cdr form)))
  69.                     (list 'cdr 'params)))))))))
  70.  
  71. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72. ;;;;
  73. ;;;; Some utilities
  74. ;;;;
  75. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76.  
  77. (define gensym 
  78.   (let ((counter 0))
  79.     (lambda prefix
  80.       (set! counter (+ counter 1))
  81.       (string->symbol
  82.          (string-append (if (null? prefix) "G" (car prefix))
  83.             (number->string counter))))))
  84.  
  85. (define (apropos s)
  86.   (if (not (symbol? s)) (error "apropos: bad symbol" s))
  87.   (let ((res '())
  88.     (env (the-environment)) 
  89.     (str (symbol->string s)))
  90.  
  91.     (do ((l (cdr (environment->list env)) (cdr l))); cdr to avoid the binding to "s"
  92.     ((null? l) (if (null? res) #f res))
  93.       (do ((v (car l) (cdr v)))
  94.       ((null? v))
  95.     (if (and (string-find? str (symbol->string (caar v))) 
  96.          (symbol-bound? (caar v)))
  97.         (set! res (cons (caar v) res)))))))
  98.  
  99. (define (documentation x)
  100.   "provides documentation for its parameter if it exists"
  101.   (define (nodoc)
  102.     (format #t "No documentation available for ~A\n" x))
  103.   (cond
  104.     ((closure? x) (let ((body (procedure-body x)))
  105.             (if (string? (caddr body)) 
  106.             (format #t "~A\n" (caddr body))
  107.             (nodoc))))))
  108.  
  109.  
  110. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  111. ;;;;
  112. ;;;; Random 
  113. ;;;;    This version of random is constructed over the C one. It can return
  114. ;;;;    bignum numbers. Idea is due to Nobuyuki Hikichi <hikichi@sra.co.jp>
  115. ;;;;
  116. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  117.  
  118. (define random 
  119.   (let ((C-random random)
  120.     (max-rand #x7fffffff)) ; Probably more on 64 bits machines
  121.     (letrec ((rand (lambda (n)
  122.              (cond 
  123.               ((zero? n)       0)
  124.               ((< n max-rand) (C-random n))
  125.               (else       (+ (* (rand (quotient n max-rand)) max-rand)
  126.                      (rand (remainder n max-rand))))))))
  127.       (lambda (n)
  128.     (if (zero? n)
  129.         (error "random: bad number: 0")
  130.         (rand n))))))
  131.  
  132. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  133. ;;;;
  134. ;;;; do
  135. ;;;;
  136. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  137.  
  138. (define-macro (do inits test . body)
  139.   (let ((loop-name (gensym)))
  140.     `(letrec ((,loop-name 
  141.            (lambda ,(map car inits)
  142.          (if ,(car test)
  143.              (begin ,@(if (null? (cdr test)) 
  144.                   (list @undefined) 
  145.                   (cdr test)))
  146.              (begin ,@body
  147.                 (,loop-name ,@(map (lambda (init)
  148.                          (if (null? (cddr init))
  149.                              (car init)
  150.                              (caddr init)))
  151.                            inits)))))))
  152.        (,loop-name ,@(map cadr inits)))))
  153.  
  154.  
  155. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  156. ;;;;
  157. ;;;; dotimes
  158. ;;;;
  159. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  160.  
  161. (define-macro (dotimes binding . body)
  162.   (if (list? binding)
  163.       ;; binding is a list
  164.       (let ((var   #f) (count #f) (result #f))
  165.     (case (length binding)
  166.       (2  (set! var    (car binding))
  167.           (set! count  (cadr binding)))
  168.       (3  (set! var    (car binding))
  169.           (set! count  (cadr binding))
  170.           (set! result (caddr binding)))
  171.       (else (error "dotimes: bad binding construct: ~S" binding)))
  172.     `(do ((,var 0 (+ ,var 1)))
  173.          ((= ,var ,count) ,result)
  174.        ,@body))
  175.       ;; binding is ill-formed
  176.       (error "dotimes: binding is not a list: ~S" binding)))
  177.  
  178.  
  179.  
  180. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  181. ;;;;
  182. ;;;; case
  183. ;;;;
  184. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  185.  
  186. (define-macro (case key . clauses)
  187.   ;; conditionally execute the clause eqv? to key
  188.   (define (case-make-clauses key)
  189.     `(cond ,@(map
  190.               (lambda (clause)
  191.                 (if (pair? clause)
  192.                     (let ((case (car clause))
  193.                           (exprs (cdr clause)))
  194.                       (cond ((eq? case 'else)
  195.                              `(else ,@exprs))
  196.                             ((pair? case)
  197.                              (if (= (length case) 1)
  198.                                  `((eqv? ,key ',(car case)) ,@exprs)
  199.                                  `((memv ,key ',case) ,@exprs)))
  200.                             (else
  201.                              `((eqv? ,key ',case) ,@exprs))))
  202.                     (error "case: invalid syntax in ~a" clause)))
  203.               clauses)))
  204.   (if (pair? key)
  205.       (let ((newkey (gensym)))
  206.         `(let ((,newkey ,key))
  207.            ,(case-make-clauses newkey)))
  208.       (case-make-clauses key)))
  209.  
  210. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  211. ;;;;
  212. ;;;; fluid-let
  213. ;;;;
  214. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  215.  
  216. (define-macro (fluid-let bindings . body)
  217.   (let* ((vars (map car bindings))
  218.      (vals (map cadr bindings))
  219.      (tmps (map (lambda (x) (gensym)) vars)))
  220.     `(let ,(map list tmps vars)
  221.        (dynamic-wind
  222.       (lambda () ,@(map (lambda (x y) `(set! ,x ,y)) vars vals))
  223.       (lambda () ,@body)
  224.       (lambda () ,@(map (lambda (x y) `(set! ,x ,y)) vars tmps))))))
  225.  
  226. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  227. ;;;;
  228. ;;;; Some usal macros 
  229. ;;;;
  230. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  231.  
  232. (define-macro (unquote form) 
  233.   (error "Usage of unquote outside of quasiquote in ,~A" form))
  234.  
  235. (define-macro (unquote-splicing form) 
  236.   (error "Usage of unquote-splicing outside of quasiquote in ,@~A" form))
  237.  
  238. (define 1+ (macro form (list + (cadr form) 1)))
  239. (define 1- (macro form (list - (cadr form) 1)))
  240.  
  241. (define macroexpand-1 macro-expand)
  242.  
  243.  
  244. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  245. ;;;;
  246. ;;;; Section 6.10
  247. ;;;;
  248. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  249.  
  250. (define (call-with-input-file string proc)
  251.   (let* ((file   (open-input-file string))
  252.      (result (proc file)))
  253.     (close-input-port file)
  254.     result))
  255.  
  256. (define (call-with-output-file string proc)
  257.   (let* ((file   (open-output-file string))
  258.      (result (proc file)))
  259.     (close-output-port file)
  260.     result))
  261.  
  262. (define (call-with-input-string string proc)
  263.   (proc (open-input-string string)))
  264.  
  265. (define (call-with-output-string proc)
  266.   (let ((str (open-output-string)))
  267.     (proc str)
  268.     (get-output-string str)))
  269.  
  270. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  271. ;;;;
  272. ;;;; File management
  273. ;;;;
  274. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  275.  
  276. (define *shared-suffix* (cond 
  277.              ((string=? (substring (machine-type) 0 2) "HP") "sl")
  278.              (ELSE      "so")))
  279. (define *load-suffixes*    (list "stk" "stklos" "scm" *shared-suffix*))
  280.  
  281. (define *load-path*    #f)
  282. (define *help-path*    #f)
  283. (define *load-verbose*     #f)
  284.  
  285.  
  286. (let ((build-path (lambda (path)
  287.             (and path 
  288.              (let ((len (string-length path))
  289.                    (new '())
  290.                    (i 0))
  291.                (do ((j 0 (+ j 1)))
  292.                    ((= j len))
  293.                  (if (eqv? (string-ref path j) #\:)
  294.                  (begin
  295.                    (set! new (cons (substring path i j) 
  296.                            new))
  297.                    (set! i (+ j 1)))))
  298.                ;; don't forget the last path
  299.                (reverse (cons (substring path i len) new))))))
  300.       (lib       (%library-location)))
  301.  
  302.   ;; If user has specified a load path with STK_LOAD_PATH, use it
  303.   ;; Always append STK_LIBRARY at end to be sure to find our files
  304.   (set! *load-path* (append (list ".")
  305.                 (or (build-path (getenv "STK_LOAD_PATH")) '())
  306.                 (list (expand-file-name 
  307.                          (string-append lib "/../site-scheme"))
  308.                   (string-append lib "/STk")
  309.                   (string-append lib "/" (machine-type)))))
  310.   ;; The same thing for the *help-path*
  311.   (set! *help-path* (append (list ".")
  312.                 (or (build-path (getenv "STK_HELP_PATH")) '())
  313.                 (list lib
  314.                   (string-append lib "/Help")))))
  315.   
  316.  
  317. ;
  318. ; Require/Provide/Provided?
  319. ;
  320. (define require   #f)
  321. (define provide   #f)
  322. (define provided? #f)
  323.  
  324. (let ((provided '()))
  325.  
  326.   (set! require (lambda (what)
  327.           (unless (member what provided)
  328.              (load what)
  329.              (unless (member what provided)
  330.             (format #t "WARNING: ~S was not provided~%" what)))
  331.           what))
  332.  
  333.   (set! provide (lambda (what)
  334.           (unless (member what provided)
  335.               (set! provided (cons what provided)))
  336.           what))
  337.     
  338.   (set! provided? (lambda (what)
  339.             (and (member what provided) #t))))
  340.  
  341. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  342. ;;;;
  343. ;;;; Port conversions
  344. ;;;;
  345. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  346.  
  347. (define (port->string p)
  348.   (unless (or (input-port? p) (input-string-port? p))
  349.      (error "port->string: Bad port ~S" p))
  350.   (let loop ((res '()))
  351.     (let ((line (read-line p)))
  352.       (if (eof-object? line)
  353.           (apply string-append (reverse res))
  354.       (loop (cons "\n" (cons line res)))))))
  355.  
  356. (define (port->list reader p)
  357.   (unless (or (input-port? p) (input-string-port? p))
  358.      (error "port->list: Bad port ~S" p))
  359.   ;; Read all the lines of port and put them in a list
  360.   (let loop ((res '()) (sexp (reader p)))
  361.     (if (eof-object? sexp) 
  362.     (reverse res)
  363.     (loop (cons sexp res) (reader p)))))
  364.  
  365. (define (port->sexp-list p) 
  366.   (port->list read p))
  367.  
  368. (define (port->string-list p)
  369.   (port->list read-line p))
  370.  
  371. (define (exec command)
  372.   (call-with-input-file (string-append "| " command) port->string))
  373.  
  374. (define (exec-string-list command)
  375.   (call-with-input-file (string-append "| " command) port->string-list))
  376.     
  377.  
  378. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  379. ;;;;
  380. ;;;; Misc
  381. ;;;;
  382. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  383.  
  384. (define (closure? obj)
  385.   (and (procedure? obj) (procedure-body obj) #t))
  386.  
  387. (define (primitive? obj)
  388.   (and (procedure? obj) (not (procedure-body obj)) #t))
  389.  
  390. (define (widget? obj)
  391.   (and (tk-command? obj) (not (catch (obj 'configure)))))
  392.  
  393.  
  394. (define (& . l)
  395.   (let loop ((l l) (res ""))
  396.     (if (null? l)
  397.         res
  398.         (let ((e (car l)))
  399.           (loop (cdr l) 
  400.         (string-append res 
  401.                    (cond 
  402.                   ((string? e) e)
  403.                   ((symbol? e) (symbol->string e))
  404.                   ((widget? e) (widget->string e))
  405.                   ((number? e) (number->string e))
  406.                   (ELSE           (format #f "~S" e)))))))))
  407.  
  408. (define-macro (unwind-protect body . unwind-forms)
  409.   `(dynamic-wind
  410.     (lambda () #f)
  411.     (lambda () ,body)
  412.     (lambda () ,@unwind-forms)))
  413.  
  414. (define-macro (when test . body)
  415.   `(if ,test ,@(if (= (length body) 1) body `((begin ,@body)))))
  416.  
  417. (define-macro (unless test . body)
  418.   `(if (not ,test) ,@(if (= (length body) 1) body `((begin ,@body)))))
  419.  
  420. (define-macro (multiple-value-bind vars form . body)
  421.   `(apply (lambda ,vars ,@body) ,form))
  422.  
  423.  
  424. ;;; 
  425. ;;; Set functions
  426. ;;;
  427.  
  428. (define (list->set l)
  429.   (letrec ((rem-dupl (lambda (l res)
  430.                (cond
  431.             ((null? l)          res)
  432.             ((memv (car l) res) (rem-dupl (cdr l) res))
  433.             (ELSE        (rem-dupl (cdr l) (cons (car l) res)))))))
  434.     (rem-dupl l '())))
  435.  
  436. (define (set-union l1 l2)
  437.   (list->set (append l1 l2)))
  438.  
  439. (define (set-intersection l1 l2)
  440.   (cond ((null? l1)          l1)
  441.     ((null? l2)          l2)
  442.     ((memv (car l1) l2)  (cons (car l1) (set-intersection (cdr l1) l2)))
  443.     (else              (set-intersection (cdr l1) l2))))
  444.  
  445. (define (set-difference l1 l2)
  446.   (cond ((null? l1)          l1)
  447.     ((memv (car l1) l2)  (set-difference (cdr l1) l2))
  448.     (else              (cons (car l1) (set-difference (cdr l1) l2)))))
  449.  
  450. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  451. ;;;;
  452. ;;;; Autoloads
  453. ;;;;
  454. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  455.  
  456. (autoload "unix"     basename dirname decompose-file-name)
  457. (autoload "process"    run-process process?)
  458. (autoload "regexp"    string->regexp regexp? regexp-replace regexp-replace-all)
  459.  
  460. ;; STklos
  461. (autoload "stklos"     define-class define-method make define-generic slot-ref 
  462.               slot-set!)
  463.  
  464. (autoload "describe"    describe)
  465. (autoload "hash"       make-hash-table hash-table-hash)
  466. (autoload "socket"       make-server-socket make-client-socket)
  467.  
  468.  
  469. ;; martine packages 
  470. (autoload "pp"    pp)
  471. (autoload "trace" trace)
  472.  
  473.  
  474.  
  475. ;;;
  476. ;;; quit and bye procedures. Since Tk redefine exit, they cannot be simple aliases
  477. ;;;
  478. (define quit (lambda l (apply exit l)))
  479. (define bye  (lambda l (apply exit l)))
  480.  
  481. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  482. ;;;;
  483. ;;;; Tk initializations
  484. ;;;;
  485. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  486.  
  487. (define Tk:initialized?  #f)
  488.  
  489. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  490. ;;;;
  491. ;;;; Try to load user init file 
  492. ;;;; Idea from (Olaf Burkart) burkart@zeus.informatik.rwth-aachen.de
  493. ;;;;
  494. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  495.  
  496. (let ((user-init ".stkrc"))
  497.   ;; First look in the current directory for an user initialization file.
  498.   (or (try-load (string-append "./" user-init))
  499.       ;; Otherwise have a look in the HOME directory.
  500.       (let ((home-dir (getenv "HOME")))
  501.     (and home-dir
  502.          (try-load (string-append home-dir "/" user-init))))))
  503.